home *** CD-ROM | disk | FTP | other *** search
/ Workbench Add-On / Workbench Add-On - Volume 1.iso / Dev / TileForth / tst / tree-sort.tst < prev   
Text File  |  1995-08-25  |  3KB  |  121 lines
  1. .( Loading Tree Sort benchmark...) cr
  2.  
  3. \ A classical benchmark of an O(log n) algorithm; Tree Sort
  4. \
  5. \ Part of the programs gathered by John Hennessy for the MIPS
  6. \ RISC project at Stanford. Translated to forth by Marty Fraeman,
  7. \ Johns Hopkins University/Applied Physics Laboratory.
  8.  
  9. : exchange ( x y -- ) dup @ rot dup @ >r ! r> swap ! ;
  10.  
  11. variable seed
  12.  
  13. : initiate-seed ( -- )  74755 seed ! ;
  14. : random  ( -- n )  seed @ 1309 * 13849 + 65535 and dup seed ! ;
  15.  
  16. \ These structure access words were originally developed by
  17. \ at JHU/APL by Ben Ballard and John Hayes
  18. \ Structure access words
  19. \ Examples of use:
  20. \ structure foo  \ declare a structure named foo
  21. \       wrd: .thing1 \ with a one word field named .thing1
  22. \    2 wrds: .thing2 \ and a two word field named .thing2
  23. \ endstructure
  24. \
  25. \ structure foobar \ another structure
  26. \           wrd: .thing
  27. \    foo struct: .blah \ nested structure
  28. \ endstructure
  29. \
  30. \ foobar makestruct test \ allocate space for a structure instance
  31. \ 1234 test .blah .thing1 ! \ access structure
  32.  
  33. : structure ( --- structure offset0)
  34.   create here 0 , 0
  35. does> ( structure -- size)
  36.   @
  37. ;
  38.  
  39. : struct: ( offset1 size --- offset2)
  40.   create over , +
  41. does> ( structure field -- field-addr)
  42.   @ +
  43. ; 
  44.  
  45. : wrds: ( offset1 size --- offset2)  cells struct: ;
  46. : wrd: ( offset1 --- offset2)  cell struct: ;
  47. : endstructure ( structure size --- ) swap ! ;
  48. : makestruct ( size --- )  create allot ;
  49. : malloc  ( structure -- instance)  here swap allot ;
  50.  
  51. \ The Tree Sort definitions:
  52.  
  53. structure node ( -- )
  54.  wrd: .left
  55.  wrd: .right
  56.  wrd: .val
  57. endstructure
  58.  
  59. 5000 constant tree-size
  60. variable tree
  61.  
  62. : create-node ( n t -- )
  63.   node malloc dup >r swap !
  64.   r@ .val !
  65.   nil r@ .left !
  66.   nil r> .right !
  67. ;
  68.  
  69. : insert-node ( n t -- )
  70.   2dup .val @ >
  71.   if dup .left @ nil =
  72.     if 2dup .left create-node
  73.     else
  74.       2dup .left @ recurse
  75.     then
  76.   else 2dup .val @ <
  77.     if dup .right @ nil =
  78.       if 2dup .right create-node
  79.       else
  80.     2dup .right @ recurse
  81.       then
  82.     then
  83.   then
  84.   2drop
  85. ;
  86.  
  87. : verify-tree ( t -- f)
  88.   true >r dup .left @ nil = not
  89.   if dup .left @ .val @ over .val @ > not
  90.     if r> drop false >r 
  91.     else dup .left @ recurse r> and >r then
  92.   then 
  93.   dup .right @ nil = not
  94.   if dup .right @ .val @ over .val @ < not
  95.     if r> drop false >r
  96.     else dup .right @ recurse r> and >r then
  97.  then
  98.  drop r>
  99. ;
  100.  
  101. : dump-tree ( t -- )
  102.   dup nil = not
  103.   if dup .right @ recurse
  104.     dup .val @ .
  105.     dup .left @ recurse
  106.   then
  107.   drop
  108. ;
  109.  
  110. : tree-sort   ( -- )
  111.   initiate-seed
  112.   random tree create-node
  113.   tree @
  114.   tree-size 0 do
  115.     random over insert-node
  116.   loop
  117.   verify-tree not abort" trees: wrong result"
  118. ;
  119.  
  120. forth only
  121.